Clickx 115/Clickx 115.iso/software/tools/windows/tails-i386-0.16.iso/live/filesystem.squashfs/usr/share/uim/util.scm

Text File | 2010-11-07 | 9.3 KB | 327 lines

;;; util.scm: Utility functions for uim.
;;;
;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. Neither the name of authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this software
;;;    without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.

(require-extension (srfi 1 6 34))

(require "ichar.scm")
(require "deprecated-util.scm")


(define hyphen-sym (string->symbol "-"))

;;
;; generic utilities
;;

(define writeln
  (lambda args
    (apply write args)
    (newline)))

;; Make escaped string literal to print a form.
;;
;; (string-escape "a str\n") -> "\"a str\\n\""
;;
;; The following two codes must display same result. See
;; test/test-util.scm for further specification.
;;
;; (display str)
;;
;; (use srfi-6)
;; (define estr (string-append "(display " (string-escape str) ")"))
;; (eval (read (open-input-string estr))
;;       (interaction-environment))
(define string-escape
  (lambda (s)
    (let ((p (open-output-string)))
      (write s p)
      (get-output-string p))))

;; procedural 'or' for use with 'apply'
;; e.g. (apply proc-or boolean-lst)
;; should be deprecated and replaced with a proper, Schemer's way
(define proc-or
  (lambda xs
    (reduce (lambda (x y)
          (or x y))
        #f xs)))

;; procedural 'and' for use with 'apply'
;; e.g. (apply proc-and boolean-lst)
;; should be deprecated and replaced with a proper, Schemer's way
(define proc-and
  (lambda xs
    (reduce (lambda (x y)
          (and x y))
        #t xs)))

;; meaning of 'end' has been changed from uim 1.5.0. See
;; doc/COMPATIBILITY and test-util.scm.
(define sublist
  (lambda (lst start end)
    (take (drop lst start)
      (- end start))))

;; meaning of 'len' has been changed from uim 1.5.0. See
;; doc/COMPATIBILITY and test-util.scm.
(define sublist-rel
  (lambda (lst start len)
    (take (drop lst start)
      len)))

(define alist-replace
  (lambda (kons alist)
    (let* ((id (car kons))
       (preexisting (assoc id alist)))
      (if preexisting
      (begin
        (set-cdr! preexisting (cdr kons))
        alist)
      (cons kons alist)))))

(define list-join
  (lambda (lst sep)
    (if (null? lst)
    '()
    (cdr (fold-right (lambda (kar kdr)
               (cons* sep kar kdr))
             '() lst)))))

;; downward compatible with SRFI-13 string-join
(define string-join
  (lambda (str-list sep)
    (apply string-append (list-join str-list sep))))

;; Split pattern has been changed from uim 1.5.0. See
;; doc/COMPATIBILITY and test-uim-util.scm.
(define string-split
  (lambda (str sep)
    (let ((slen (string-length str))
      (seplen (string-length sep)))
      (let rec ((start 0))
    (let ((next (and (<= start slen)
             (string-contains str sep start))))
      (if next
          (cons (substring str start next)
            (rec (+ next seplen)))
          (list (substring str start slen))))))))

(define string-append-map
  (lambda args
    (apply string-append (apply map args))))

;; symbol-append is a de facto standard procedure name
(define symbol-append
  (lambda args
    (string->symbol (string-append-map symbol->string args))))

;; only accepts single-arg functions
;; (define caddr (compose car cdr cdr))
;; FIXME: remove the closure overhead
(define compose
  (lambda funcs
    (reduce-right (lambda (f g)
            (lambda (x)
              (f (g x))))
          values funcs)))

(define method-delegator-new
  (lambda (dest-getter method)
    (lambda (self . args)
      (apply method (cons (dest-getter self) args)))))

(define safe-car
  (lambda (pair)
    (and (pair? pair)
     (car pair))))

(define safe-cdr
  (lambda (pair)
    (and (pair? pair)
     (cdr pair))))

(define assq-cdr
  (lambda (key alist)
    (safe-cdr (assq key alist))))

(define clamp
  (lambda (x bottom ceiling)
    (max bottom
     (min x ceiling))))


;;
;; uim-specific utilities
;;

(define do-nothing (lambda args #f))

(define make-scm-pathname
  (lambda (file)
    (if (string-prefix? "/" file)
    file
    (string-append (load-path) "/" file))))

;; TODO: write test
;; returns succeeded or not
(define try-load
  (lambda (file)
    (guard (err
        (else #f))
      ;; to suppress error message, check file existence first
      (and (file-readable? (make-scm-pathname file))
       (load file)))))

;; TODO: write test
;; returns succeeded or not
(define try-require
  (lambda (file)
    (guard (err
        (else #f))
      ;; to suppress error message, check file existence first
      (and (file-readable? (make-scm-pathname file))
       (require file)))))

;; used for dynamic environment substitution of closure
(define %%enclose-another-env
  (lambda (closure another-env)
    (let* ((code (%%closure-code closure))
       (args (car code))
       (body (cdr code))
       (definition (list 'lambda args body)))
      (eval definition another-env))))

;; See test/test-util.scm to know what define-record does.
;; rec-spec requires list of list rather than alist to keep
;; extensibility (e.g. (nth 2 spec) and so on may be used)
(define define-record
  (lambda (rec-sym rec-spec)
    (for-each (lambda (spec index)
        (let* ((elem-sym (list-ref spec 0))
               (default  (list-ref spec 1))
               (getter-sym (symbol-append rec-sym hyphen-sym elem-sym))
               (getter (lambda (rec)
                 (list-ref rec index)))
               (setter-sym (symbol-append
                    rec-sym hyphen-sym 'set- elem-sym '!))
               (setter (lambda (rec val)
                 (set-car! (list-tail rec index)
                       val))))
          (eval (list 'define getter-sym getter)
            (interaction-environment))
          (eval (list 'define setter-sym setter)
            (interaction-environment))))
          rec-spec
          (iota (length rec-spec)))
    (let ((creator-sym (symbol-append rec-sym hyphen-sym 'new))
      (creator (let ((defaults (map cadr rec-spec)))
             (lambda init-lst
               (cond
            ((null? init-lst)
             (list-copy defaults))
            ;; fast path
            ((= (length init-lst)
                (length defaults))
             (list-copy init-lst))
            ;; others
            ((< (length init-lst)
                (length defaults))
             (let* ((rest-defaults (list-tail defaults
                              (length init-lst)))
                (complemented-init-lst (append init-lst
                                   rest-defaults)))
               (list-copy complemented-init-lst)))
            (else
             #f))))))
      (eval (list 'define creator-sym creator)
        (interaction-environment)))))

;; for direct candidate selection
(define number->candidate-index
  (lambda (n)
    (cond
     ((= n 0)
      9)
     ((and (>= n 1)
       (<= n 9))
      (- n 1))
     (else
      n))))

;; update style-element vars
;; style-spec requires list of (style-element-name . validator)
(define update-style
  (lambda (style-spec style)
    (let* ((elem (car style))
       (name (car elem))
       (val (if (symbol? (cdr elem))
            (symbol-value (cdr elem))
            (cdr elem)))
       (spec (assq name style-spec))
       (valid? (symbol-value (cdr spec))))
      (if (valid? val)
      (set-symbol-value! name val))
      (if (not (null? (cdr style)))
      (update-style style-spec (cdr style))))))

;;
;; Preedit color related configurations and functions.
;;
(define reversed-preedit-foreground #f)
(define reversed-preedit-background #f)
(define separator-foreground #f)
(define separator-background #f)
(define reversed-separator-foreground #f)
(define reversed-separator-background #f)

(define uim-color-spec
  '((reversed-preedit-foreground   . string?)
    (reversed-preedit-background   . string?)
    (separator-foreground          . string?)
    (separator-background          . string?)
    (reversed-separator-foreground . string?)
    (reversed-separator-background . string?)))

;; predefined color styles
(define uim-color-uim
  '((reversed-preedit-foreground   . "white")
    (reversed-preedit-background   . "black")
    (separator-foreground          . "lightsteelblue")
    (separator-background          . "")
    (reversed-separator-foreground . "white")
    (reversed-separator-background . "black")))
(define uim-color-atok
  '((reversed-preedit-foreground   . "black")
    (reversed-preedit-background   . "cyan")
    (separator-foreground          . "lightsteelblue")
    (separator-background          . "")
    (reversed-separator-foreground . "black")
    (reversed-separator-background . "blue")))